home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / nrpas13.arc / QCKSRT.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-01  |  2KB  |  86 lines
  1. PROCEDURE qcksrt(n: integer; VAR arr: glarray);
  2. (* Programs using routine QCKSRT must define the type
  3. TYPE
  4.    glarray = ARRAY [1..np] OF real;
  5. in the main routine, with np >= n.   *)
  6. LABEL 11,21,22,30,99;
  7. CONST
  8.    m=7;
  9.    nstack=50;
  10.    fm=7875;
  11.    fa=211.0;
  12.    fc=1663.0;
  13. VAR
  14.    l,jstack,j,ir,iq,i: integer;
  15.    fx,fmi,a: real;
  16.    istack: ARRAY[1..nstack] OF integer;
  17. BEGIN
  18.    fmi := 1.0/fm;
  19.    jstack := 0;
  20.    l := 1;
  21.    ir := n;
  22.    fx := 0.0;
  23.    WHILE true DO BEGIN
  24.       IF ((ir-l) < m) THEN BEGIN
  25.          FOR j := l+1 TO ir DO BEGIN
  26.             a := arr[j];
  27.             FOR i := j-1 DOWNTO 1 DO BEGIN
  28.                IF (arr[i] <= a) THEN GOTO 11;
  29.                arr[i+1] := arr[i]
  30.             END;
  31.             i := 0;
  32. 11:            arr[i+1] := a
  33.          END;
  34.          IF (jstack = 0) THEN GOTO 99;
  35.          ir := istack[jstack];
  36.          l := istack[jstack-1];
  37.          jstack := jstack-2
  38.       END ELSE BEGIN
  39.          i := l;
  40.          j := ir;
  41.          fx := (fx*fa+fc)/fm;
  42.          fx := fx-trunc(fx);
  43.          iq := l+(ir-l+1)*trunc(fx*fmi);
  44.          a := arr[iq];
  45.          arr[iq] := arr[l];
  46. 21:         IF (j > 0) THEN BEGIN
  47.             IF (a < arr[j]) THEN BEGIN
  48.                j := j-1;
  49.                GOTO 21
  50.             END
  51.          END;
  52.          IF (j <= i) THEN BEGIN
  53.             arr[i] := a;
  54.             GOTO 30
  55.          END;
  56.          arr[i] := arr[j];
  57.          i := i+1;
  58. 22:         IF (i <= n) THEN IF (a > arr[i]) THEN BEGIN
  59.             i := i+1;
  60.             GOTO 22
  61.          END;
  62.          IF (j <= i) THEN BEGIN
  63.             arr[j] := a;
  64.             i := j;
  65.             GOTO 30
  66.          END;
  67.          arr[j] := arr[i];
  68.          j := j-1;
  69.          GOTO 21;
  70. 30:         jstack := jstack+2;
  71.          IF (jstack > nstack) THEN BEGIN
  72.             writeln('pause in QCKSRT - NSTACK must be made larger'); readln
  73.          END;
  74.          IF ((ir-i) >= (i-l)) THEN BEGIN
  75.             istack[jstack] := ir;
  76.             istack[jstack-1] := i+1;
  77.             ir := i-1
  78.          END ELSE BEGIN
  79.             istack[jstack] := i-1;
  80.             istack[jstack-1] := l;
  81.             l := i+1
  82.          END
  83.       END
  84.    END;
  85. 99:   END;
  86.